home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-04 / bipl.zip / PROGS.ZIP / PRESS.ICN < prev    next >
Text File  |  1993-01-27  |  26KB  |  893 lines
  1. ############################################################################
  2. #
  3. #    File:     press.icn
  4. #
  5. #    Subject:  Program to archive files
  6. #
  7. #    Author:   Robert J. Alexander
  8. #
  9. #    Date:     November 14, 1991
  10. #
  11. ###########################################################################
  12. #
  13. #  Besides being a useful file archiving utility, this program can be
  14. #  used to experiment with the LZW compression process, as it contains
  15. #  extensive tracing facilities that illustrate the process in detail.
  16. #
  17. #  Compression can be turned off if faster archiving is desired.
  18. #
  19. #  The LZW compression procedures in this program are general purpose
  20. #  and suitable for reuse in other programs.
  21. #
  22. ############################################################################
  23. #
  24. #  Instructions for use are summarized in "help" procedures that follow.
  25. #
  26. ############################################################################
  27. #
  28. #  Links: options, colmize, wildcard
  29. #
  30. ############################################################################
  31.  
  32. link options, colmize, wildcard
  33.  
  34. procedure Usage(s)
  35.    /s := ""
  36.    stop("\nUsage:_
  37. \n      Compress: press -c <archive file> [<options>] [<file to compress>...]_
  38. \n      Archive:  press -a <archive file> [<options>] [<file to archive>...]_
  39. \n      Extract:  press -x <archive file> [<options>] [<file to extract>...]_
  40. \n      Print:    press -p <archive file> [<options>] [<file to print>...]_
  41. \n      List:     press -l <archive file> [<options>] [<file to list>...]_
  42. \n      Delete:   press -d <archive file> [<options>] <file to delete>..._
  43. \n_
  44. \n      Help:     press         (prints this message)_
  45. \n      More help:press -h      (prints more details)_
  46. \n_
  47. \n      -c  perform compression into <archive file>_
  48. \n      -a  add file(s) to <archive file> in uncompressed format_
  49. \n      -x  extract (& decompress) file(s) from <archive file>_
  50. \n      -p  extract (& decompress) from <archive file> to standard output_
  51. \n      -l  list file names in <archive file>_
  52. \n      -d  delete file(s) from <archive file>_
  53. \n          (produces new file -- old file saved with \".bak\" suffix)_
  54. \n_
  55. \n      Options:_
  56. \n      -q  work quietly_
  57. \n      -t  text file(s) (retrieves with correct line end format)_
  58. \n    -n  process all files in archive *except* specified files_
  59. \n_
  60. \n      LZW Experimentor Options:_
  61. \n      -T  produce detailed compression trace info (to standard error file)_
  62. \n      -S  maximum compression string table size_
  63. \n          (for -c only -- default = 1024)_
  64. \n"
  65.       ,s)
  66. end
  67.  
  68. procedure MoreHelp()
  69.    return "\n _
  70.   The archive (-a) option means to add the file without compression._
  71. \n_
  72. \n If no files are specified to extract, print, or list, then all files_
  73. \n in the archive are used._
  74. \n_
  75. \n UNIX-style filename wildcard conventions can be used to express_
  76. \n the archived file names for extract, print, list, and delete_
  77. \n operations.  Be sure to quote names containing wildcard characters_
  78. \n so that they aren't expanded by the shell (if applicable)._
  79. \n_
  80. \n If a <file to compress> or <file to archive> is \"-\", or if no files_
  81. \n are specified, standard input is archived._
  82. \n_
  83. \n If <archive file> for extract, print, or list is \"-\", standard input_
  84. \n is the archive file._
  85. \n_
  86. \n If <archive file> for compress or archive is \"-\", archive is written_
  87. \n to standard output._
  88. \n_
  89. \n New files archived to an existing archive file are always appended,_
  90. \n deleting any previously archived version of the same file name._
  91. \n_
  92. \n Archive files can be simply concatenated to create their union._
  93. \n However, if the same file exists in both archives, only the first_
  94. \n in the resulting file will be able to be accessed._
  95. \n_
  96. \n If a \"compressed\" file turns out to be longer than the uncompressed_
  97. \n file (rare but possible, usually for very short files), the file will_
  98. \n automatically be archived in uncompressed format._
  99. \n_
  100. \n A default file name suffix of \".prx\" is assumed for <archive file>_
  101. \n names that are specified without a suffix._
  102. \n_
  103. \n_
  104. \n LZW \"internals\" option:_
  105. \n_
  106. \n If the specified maximum table size is positive, the string table is_
  107. \n discarded when the maximum size is reached and rebuilt (usually the_
  108. \n better choice).  If negative, the original table is not discarded,_
  109. \n which might produce better results in some circumstances.  This_
  110. \n option was provided primarily for experimentors._
  111. \n"
  112. end
  113.  
  114. #
  115. #  Global variables.
  116. #
  117. #  Note:  additional globals that contain option values are defined near
  118. #  Options(), below.
  119. #
  120. global inchars,outchars,tinchars,toutchars,lzw_recycles,
  121.       lzw_stringTable,rf,wf,magic,rline,wline
  122.  
  123. #
  124. #  Main procedure.
  125. #
  126. procedure main(arg)
  127.    local arcfile
  128.    #
  129.    #  Initialize.
  130.    #
  131.    Options(arg)
  132.    inchars := outchars := tinchars := toutchars := lzw_recycles := 0
  133.    magic := "\^p\^r\^e\^s\^s\^i\^c\^n"
  134.    #
  135.    #  Do requested operation.
  136.    #
  137.    arcfile :=
  138.          DefaultSuffix(\(compr | archive | extract | print | lister | deleter),
  139.          "prx") | Usage()
  140.    if \(compr | archive) then Archive(arcfile,arg)
  141.    else if \(extract | print) then Extract(arcfile,arg)
  142.    else if \lister then List(arcfile,arg)
  143.    else if \deleter then Delete(arcfile,arg)
  144.    return
  145. end
  146.  
  147.  
  148. #
  149. #  Option global variables.
  150. #
  151. global lzw_trace,maxTableSpecified,maxTableSize,print,quiet,tmode,WildMatch
  152. global extract,compr,archive,lister,deleter
  153.  
  154. #
  155. #  Options() -- Handle command line options.
  156. #
  157. procedure Options(arg)
  158.    local opt,n,x
  159.    opt := options(arg,"hc:a:x:p:l:d:qtTS+n")
  160.    if \opt["h"] then Usage(MoreHelp())
  161.    extract := opt["x"]
  162.    print := opt["p"]
  163.    compr := opt["c"]
  164.    archive := opt["a"]
  165.    lister := opt["l"]
  166.    deleter := opt["d"]
  167.    quiet := opt["q"]
  168.    tmode := if \opt["t"] then "t" else "u"
  169.    WildMatch := if \opt["n"] then not_wild_match else whole_wild_match
  170.    lzw_trace := opt["T"]
  171.    maxTableSpecified := opt["S"]
  172.    maxTableSize := \maxTableSpecified | 1024    # 10 bits default
  173.    n := 0
  174.    every x := compr | archive | extract | print | lister | deleter do
  175.          if \x then n +:= 1
  176.    if n ~= 1 then Usage()
  177.    return
  178. end
  179.  
  180.  
  181. #
  182. #  Archive() -- Do archiving.
  183. #
  184. procedure Archive(arcfile,arg)
  185.    local fn,addr,realLen,maxT,length,addr2,deleteFiles,new_data_start
  186.    #
  187.    #  Confirm options and open the archive file.
  188.    #
  189.    if *arg = 0 | WildMatch === not_wild_match then Usage()
  190.    if ("" | "-") ~== arcfile then {
  191.       if wf := open(arcfile,"ru") then {
  192.          if not (reads(wf,*magic) == magic) then {
  193.             stop("Invalid archive file ",arcfile)
  194.             }
  195.          close(wf)
  196.          }
  197.       wf := open(arcfile,"bu" | "wu") | stop("Can't open archive file ",arcfile)
  198.       if tmode == "t" then rline := "\n"
  199.       seek(wf,0)
  200.       if where(wf) = 1 then writes(wf,magic)
  201.       }
  202.    else {
  203.       wf := &output
  204.       arcfile := "stdout"
  205.       }
  206.    new_data_start := where(wf)
  207.    ## if /quiet then 
  208.    ##    write(&errout,"New data starting at byte ",new_data_start," of ",arcfile)
  209.    #
  210.    #  Loop to process files on command line.
  211.    #
  212.    if *arg = 0 then arg := ["-"]
  213.    deleteFiles := []
  214.    every fn := !arg do {
  215.       if fn === arcfile then next
  216.       if /quiet then
  217.          writes(&errout,"File \"",fn,"\" -- ")
  218.       rf := if fn ~== "-" then open(fn,tmode) | &null else &input
  219.       if /rf then {
  220.          if /quiet then
  221.             write(&errout,"Can't open input file \"",fn,"\" -- skipped")
  222.          next
  223.          }
  224.       put(deleteFiles,fn)
  225.       WriteString(wf,Tail(fn))
  226.       addr := where(rf)
  227.       seek(rf,0)
  228.       realLen := where(rf) - 1
  229.       WriteInteger(wf,realLen)
  230.       seek(rf,addr)
  231.       if /quiet then
  232.          writes(&errout,"Length: ",realLen)
  233.       addr := where(wf)
  234.       WriteInteger(wf,0)
  235.       writes(wf,"\1")    # write a compression version string
  236.       if \compr then {
  237.          WriteInteger(wf,maxTableSize)
  238.          maxT := Compress(R,W,maxTableSize)
  239.          length := outchars + 4
  240.          if /quiet then
  241.             writes(&errout,"  Compressed: ",length,"  ",
  242.                   Percent(realLen - outchars,realLen))
  243.          }
  244.       #
  245.       #  If compressed file is larger than original, just copy the original.
  246.       #
  247.       if \archive | length > realLen then {
  248.          if /quiet then
  249.             writes(&errout," -- Archived uncompressed")
  250.          seek(wf,addr + 4)
  251.          writes(wf,"\0") # write a zero version string for uncompressed
  252.          seek(rf,1)
  253.          CopyFile(rf,wf)
  254.          inchars := outchars := length := realLen
  255.          maxT := 0
  256.          lzw_stringTable := ""
  257.          }
  258.       if /quiet then
  259.          write(&errout)
  260.       close(rf)
  261.       addr2 := where(wf)
  262.       seek(wf,addr)
  263.       WriteInteger(wf,length)
  264.       seek(wf,addr2)
  265.       if /quiet then
  266.          Stats(maxT)
  267.       }
  268.    close(wf)
  269.    if /quiet then
  270.       if *arg > 1 then FinalStats()
  271.    Delete(arcfile,deleteFiles,new_data_start)
  272.    return
  273. end
  274.  
  275.  
  276. #
  277. #  Extract() -- Extract a file from the archive.
  278. #
  279. procedure Extract(arcfile,arg)
  280.    local fileSet,wfn,realLen,cmprLen,maxT,version,theArg
  281.    if \maxTableSpecified then Usage()
  282.    rf := OpenReadArchive(arcfile)
  283.    arcfile := rf[2]
  284.    rf := rf[1]
  285.    if *arg > 0 then fileSet := set(arg)
  286.    #
  287.    #  Process input file.
  288.    #
  289.    while wfn := ReadString(rf) do {
  290.       (realLen := ReadInteger(rf) &
  291.             cmprLen := ReadInteger(rf) &
  292.             version := ord(reads(rf))) |
  293.             stop("Bad format in compressed file")
  294.       if /quiet then
  295.          writes(&errout,"File \"",wfn,"\" -- length: ",realLen,
  296.                "  compressed: ",cmprLen," bytes -- ")
  297.       if /fileSet | WildMatch(theArg := !arg,wfn) then {
  298.          delete(\fileSet,theArg)
  299.          if not version = (0 | 1) then {
  300.          if /quiet then
  301.                write(&errout,"can't handle this compression type (",version,
  302.                      ") -- skipped")
  303.             seek(rf,where(rf) + cmprLen)
  304.             }
  305.          else {
  306.             if /quiet then
  307.                write(&errout,"extracted")
  308.             if /print then {
  309.                wf := open(wfn,"w" || tmode) | &null
  310.                if /wf then {
  311.                   if /quiet then
  312.                      write(&errout,"Can't open output file \"",wfn,
  313.                            "\" -- quitting")
  314.                   exit(1)
  315.                   }
  316.                }
  317.             else wf := &output
  318.             if version = 1 then {
  319.                maxT := ReadInteger(rf) |
  320.                      stop("Error in archive file format: ","table size missing")
  321.                Decompress(R,W,maxT)
  322.                }
  323.             else {
  324.                maxT := 0
  325.                CopyFile(rf,wf,cmprLen)
  326.                outchars := inchars := realLen
  327.                }
  328.             close(&output ~=== wf)
  329.             if /quiet then
  330.                Stats(maxT)
  331.             }
  332.          }
  333.       else {
  334.          if /quiet then
  335.             write(&errout,"skipped")
  336.          seek(rf,where(rf) + cmprLen)
  337.          }
  338.       }
  339.    close(rf)
  340.    FilesNotFound(fileSet)
  341.    return
  342. end
  343.  
  344.  
  345. #
  346. #  List() -- Skip through the archive, extracting info about files,
  347. #  then list in columns.
  348. #
  349. procedure List(arcfile,arg)
  350.    local fileSet,flist,wfn,realLen,cmprLen,version,theArg
  351.    if \maxTableSpecified then Usage()
  352.    rf := OpenReadArchive(arcfile)
  353.    arcfile := rf[2]
  354.    rf := rf[1]
  355.    write(&errout,"Archive file ",arcfile,":")
  356.    if *arg > 0 then fileSet := set(arg)
  357.    #
  358.    #  Process input file.
  359.    #
  360.    flist := []
  361.    while wfn := ReadString(rf) do {
  362.       (realLen := ReadInteger(rf) &
  363.             cmprLen := ReadInteger(rf) &
  364.             version := ord(reads(rf))) |
  365.             stop("Bad format in compressed file")
  366.       if /fileSet | WildMatch(theArg := !arg,wfn) then {
  367.          delete(\fileSet,theArg)
  368.          put(flist,"\"" || wfn || "\" " || realLen || "->" || cmprLen)
  369.          tinchars +:= realLen
  370.          toutchars +:= cmprLen
  371.          }
  372.       seek(rf,where(rf) + cmprLen)
  373.       }
  374.    close(rf)
  375.    every write(&errout,colmize(sort(flist)))
  376.    FilesNotFound(fileSet)
  377.    FinalStats()
  378.    return
  379. end
  380.  
  381.  
  382. #
  383. #  Delete() -- Delete a file from the archive.
  384. #
  385. procedure Delete(arcfile,arg,new_data_start)
  386.    local workfn,workf,fileSet,wfn,realLen,cmprLen,bakfn,deletedFiles,
  387.          head,version,hdrLen,theArg
  388.    if *arg = 0 | (\deleter & \maxTableSpecified) then Usage()
  389.    rf := OpenReadArchive(arcfile)
  390.    arcfile := rf[2]
  391.    rf := rf[1]
  392.    workfn := Root(arcfile) || ".wrk"
  393.    workf := open(workfn,"wu") | stop("Can't open work file ",workfn)
  394.    writes(workf,magic)
  395.    fileSet := set(arg)
  396.    #
  397.    #  Process input file.
  398.    #
  399.    deletedFiles := 0
  400.    head := if \deleter then "File" else "Replaced file"
  401.    while not (\new_data_start <= where(rf)) & wfn := ReadString(rf) do {
  402.       (realLen := ReadInteger(rf) &
  403.             cmprLen := ReadInteger(rf) &
  404.             version := ord(reads(rf))) |
  405.             stop("Bad format in compressed file")
  406.       if /quiet then
  407.          writes(&errout,head," \"",wfn,"\" -- length: ",realLen,
  408.                "  compressed: ",cmprLen," bytes -- ")
  409.       if WildMatch(theArg := !arg,wfn) then {
  410.          deletedFiles +:= 1
  411.          delete(fileSet,theArg)
  412.          if /quiet then
  413.             write(&errout,"deleted")
  414.          seek(rf,where(rf) + cmprLen)
  415.          }
  416.       else {
  417.          if /quiet then
  418.             write(&errout,"kept")
  419.          hdrLen := *wfn + 10
  420.          seek(rf,where(rf) - hdrLen)
  421.          CopyFile(rf,workf,cmprLen + hdrLen)
  422.          }
  423.       }
  424.    if deletedFiles > 0 then {
  425.       CopyFile(rf,workf)
  426.       every close(workf | rf)
  427.       if (rf ~=== &input) then {
  428.          bakfn := Root(arcfile) || ".bak"
  429.          remove(bakfn)
  430.          rename(arcfile,bakfn) | stop("Couldn't rename ",arcfile," to ",bakfn)
  431.          }
  432.       rename(workfn,arcfile) | stop("Couldn't rename ",workfn," to ",arcfile)
  433.       }
  434.    else {
  435.       every close(workf | rf)
  436.       remove(workfn)
  437.       }
  438.    if \deleter then FilesNotFound(fileSet)
  439.    return
  440. end
  441.  
  442.  
  443. #
  444. #  OpenReadArchive() -- Open an archive for reading.
  445. #
  446. procedure OpenReadArchive(arcfile)
  447.    local rf
  448.    rf := if ("" | "-") ~== arcfile then
  449.          open(arcfile,"ru") | stop("Can't open archive file ",arcfile)
  450.    else {
  451.       arcfile := "stdin"
  452.       &input
  453.       }
  454.    if reads(rf,*magic) ~== magic then stop("Invalid archive file ",arcfile)
  455.    if tmode == "t" then wline := "\x0a"
  456.    return [rf,arcfile]
  457. end
  458.  
  459.  
  460. #
  461. #  FilesNotFound() -- List the files remaining in "fileSet".
  462. #
  463. procedure FilesNotFound(fileSet)
  464.    return if *\fileSet > 0 then {
  465.       write(&errout,"\nFiles not found:")
  466.       every write(&errout," ",colmize(sort(fileSet),78))
  467.       &null
  468.       }
  469. end
  470.  
  471.  
  472. #
  473. #  Stats() -- Print stats after a file.
  474. #
  475. procedure Stats(maxTableSize)
  476.    #
  477.    #  Write statistics
  478.    #
  479.    if \lzw_trace then write(&errout,
  480.          "  table size = ",*lzw_stringTable,"/",maxTableSize,
  481.          " (recycles: ",lzw_recycles,")")
  482.    tinchars +:= inchars
  483.    toutchars +:= outchars
  484.    inchars := outchars := lzw_recycles := 0
  485.    return
  486. end
  487.  
  488.  
  489. #
  490. #  FinalStats() -- Print final stats.
  491. #
  492. procedure FinalStats()
  493.    #
  494.    #  Write final statistics
  495.    #
  496.    write(&errout,"\nTotals: ",
  497.          "\n  input: ",tinchars,
  498.          "\n  output: ",toutchars,
  499.          "\n  compression: ",Percent(tinchars - toutchars,tinchars) | "",
  500.          "\n")
  501.    return
  502. end
  503.  
  504.  
  505. #
  506. #  WriteInteger() -- Write a 4-byte binary integer to "f".
  507. #
  508. procedure WriteInteger(f,i)
  509.    local s
  510.    s := ""
  511.    every 1 to 4 do {
  512.       s := char(i % 256) || s
  513.       i /:= 256
  514.       }
  515.    return writes(f,s)
  516. end
  517.  
  518.  
  519. #
  520. #  ReadInteger() -- Read a 4-byte binary integer from "f".
  521. #
  522. procedure ReadInteger(f)
  523.    local s,v
  524.    s := reads(f,4) | fail
  525.    if *s < 4 then
  526.          stop("Error in archive file format: ","bad integer")
  527.    v := 0
  528.    s ? while v := v * 256 + ord(move(1))
  529.    return v
  530. end
  531.  
  532.  
  533. #
  534. #  WriteString() -- Write a string preceded by a length byte to "f".
  535. #
  536. procedure WriteString(f,s)
  537.    return writes(f,char(*s),s)
  538. end
  539.  
  540.  
  541. #
  542. #  ReadString() -- Read a string preceded by a length byte from "f".
  543. #
  544. procedure ReadString(f)
  545.    local len,s
  546.    len := ord(reads(f)) | fail
  547.    s := reads(f,len)
  548.    if *s < len then
  549.          stop("Error in archive file format: ","bad string")
  550.    return s
  551. end
  552.  
  553.  
  554. #
  555. #  CopyFile() -- Copy a file.
  556. #
  557. procedure CopyFile(rf,wf,len)
  558.    local s
  559.    if /len then {
  560.       while writes(wf,s := reads(rf,1000))
  561.       }
  562.    else {
  563.       while len > 1000 & writes(wf,s := reads(rf,1000)) do len -:= *s
  564.       writes(wf,s := reads(rf,len)) & len -:= *s
  565.       }
  566.    return len
  567. end
  568.  
  569.  
  570. #
  571. #  Percent() -- Format a rational number "n"/"d" as a percentage.
  572. #
  573. procedure Percent(n,d)
  574.    local sign,whole,fraction
  575.    n / (0.0 ~= d) ? {
  576.       sign := ="-" | ""
  577.       whole := tab(find("."))
  578.       move(1)
  579.       fraction := tab(0)
  580.       }
  581.    return (\sign || ("0" ~== whole | "") ||
  582.          (if whole == "0" then integer else 1)(left(fraction,2,"0")) | "--") ||
  583.          "%"
  584. end
  585.  
  586.  
  587. #
  588. #  R() -- Read-a-character procedure.
  589. #
  590. procedure R()
  591.    local c
  592.  
  593.    c := reads(rf) | fail
  594.    inchars +:= 1
  595.    if c === rline then c := "\x0a"
  596.    return c
  597. end
  598.  
  599.  
  600. #
  601. #  W() -- Write-characters procedure.
  602. #
  603. procedure W(s)
  604.    local i
  605.  
  606.    every i := find(\wline,s) do s[i] := "\n"
  607.    outchars +:= *s
  608.    return writes(wf,s)
  609. end
  610.  
  611.  
  612. #
  613. #  Tail() -- Return the file name portion (minus the path) of a
  614. #  qualified file name.
  615. #
  616. procedure Tail(fn)
  617.    local i
  618.    i := 0
  619.    every i := upto('/\\:',fn)
  620.    return .fn[i + 1:0]
  621. end
  622.  
  623.  
  624. #
  625. #  Root() -- Return the root portion (minus the suffix) of a file name.
  626. #
  627. procedure Root(fn)
  628.    local i
  629.    i := 0
  630.    every i := find(".",fn)
  631.    return .fn[1:i]
  632. end
  633.  
  634.  
  635. procedure DefaultSuffix(fn,suf)
  636.    local i
  637.    return fn || "." || suf
  638. end
  639.  
  640.  
  641. ############################################################################
  642. #
  643. #  Compress() -- LZW compression
  644. #
  645. #  Arguments:
  646. #
  647. #       inproc  a procedure that returns a single character from
  648. #               the input stream.
  649. #
  650. #       outproc a procedure that writes a single character (its
  651. #               argument) to the output stream.
  652. #
  653. #       maxTableSize    the maximum size to which the string table
  654. #               is allowed to grow before something is done about it.
  655. #               If the size is positive, the table is discarded and
  656. #               a new one started.  If negative, it is retained, but
  657. #               no new entries are added.
  658. #
  659.  
  660. procedure Compress(inproc,outproc,maxTableSize)
  661.    local EOF,c,charTable,junk1,junk2,outcode,s,t,tossTable,x
  662.    #
  663.    #  Initialize.
  664.    #
  665.    /maxTableSize := 1024        # default 10 "bits"
  666.    tossTable := maxTableSize
  667.    /lzw_recycles := 0
  668.    if maxTableSize < 0 then maxTableSize := -maxTableSize
  669.    charTable := table()
  670.    every c := !&cset do charTable[c] := ord(c)
  671.    EOF := charTable[*charTable] := *charTable    # reserve code=256 for EOF
  672.    lzw_stringTable := copy(charTable)
  673.    #
  674.    #  Compress the input stream.
  675.    #
  676.    s := inproc() | return maxTableSize
  677.    if \lzw_trace then {
  678.       write(&errout,"\nInput string\tOutput code\tNew table entry")
  679.       writes(&errout,"\"",image(s)[2:-1])
  680.       }
  681.    while c := inproc() do {
  682.       if \lzw_trace then
  683.             writes(&errout,image(c)[2:-1])
  684.       if \lzw_stringTable[t := s || c] then s := t
  685.       else {
  686.          Compress_output(outproc,junk2 := lzw_stringTable[s],
  687.                junk1 := *lzw_stringTable)
  688.          if *lzw_stringTable < maxTableSize then
  689.                lzw_stringTable[t] := *lzw_stringTable
  690.          else if tossTable >= 0 then {
  691.                lzw_stringTable := copy(charTable)
  692.                lzw_recycles +:= 1
  693.             }
  694.          if \lzw_trace then
  695.                writes(&errout,"\"\t\t",
  696.                      image(char(*&cset > junk2) | junk2),
  697.                      "(",junk1,")\t\t",lzw_stringTable[t]," = ",image(t),"\n\"")
  698.          s := c
  699.          }
  700.       }
  701.       Compress_output(outproc,junk2 := lzw_stringTable[s],
  702.         junk1 := *lzw_stringTable)
  703.       if *lzw_stringTable < maxTableSize then
  704.         {}
  705.       else if tossTable >= 0 then {
  706.         lzw_stringTable := copy(charTable)
  707.         lzw_recycles +:= 1
  708.      }
  709.       if \lzw_trace then
  710.         writes(&errout,"\"\t\t",
  711.           image(char(*&cset > junk2) | junk2),"(",junk1,")\n")
  712.    Compress_output(outproc,EOF,*lzw_stringTable)
  713.    if \lzw_trace then write(&errout,"\"\t\t",EOF)
  714.    Compress_output(outproc)
  715.    return maxTableSize
  716. end
  717.  
  718.  
  719. procedure Compress_output(outproc,code,stringTableSize)
  720.    local outcode
  721.    static max,bits,buffer,bufferbits,lastSize
  722.    #
  723.    #  Initialize.
  724.    #
  725.    initial {
  726.       lastSize := 1000000
  727.       buffer := bufferbits := 0
  728.       }
  729.    #
  730.    #  If this is "close" call, flush buffer and reinitialize.
  731.    #
  732.    if /code then {
  733.       outcode := &null
  734.       if bufferbits > 0 then
  735.             outproc(char(outcode := ishift(buffer,8 - bufferbits)))
  736.       lastSize := 1000000
  737.       buffer := bufferbits := 0
  738.       return outcode
  739.       }
  740.    #
  741.    #  Expand output code size if necessary.
  742.    #
  743.    if stringTableSize < lastSize then {
  744.       max := 1
  745.       bits := 0
  746.       }
  747.    while stringTableSize > max do {
  748.       max *:= 2
  749.       bits +:= 1
  750.       }
  751.    lastSize := stringTableSize
  752.    #
  753.    #  Merge new code into buffer.
  754.    #
  755.    buffer := ior(ishift(buffer,bits),code)
  756.    bufferbits +:= bits
  757.    #
  758.    #  Output bits.
  759.    #
  760.    while bufferbits >= 8 do {
  761.       outproc(char(outcode := ishift(buffer,8 - bufferbits)))
  762.       buffer := ixor(buffer,ishift(outcode,bufferbits - 8))
  763.       bufferbits -:= 8
  764.       }
  765.    return outcode
  766. end
  767.  
  768.  
  769. ############################################################################
  770. #
  771. #  Decompress() -- LZW decompression of compressed stream created
  772. #                  by Compress()
  773. #
  774. #  Arguments:
  775. #
  776. #       inproc  a procedure that returns a single character from
  777. #               the input stream.
  778. #
  779. #       outproc a procedure that writes a single character (its
  780. #               argument) to the output stream.
  781. #
  782.  
  783. procedure Decompress(inproc,outproc,maxTableSize)
  784.    local EOF,c,charSize,code,i,new_code,old_strg,
  785.          strg,tossTable
  786.    #
  787.    #  Initialize.
  788.    #
  789.    /maxTableSize := 1024        # default 10 "bits"
  790.    tossTable := maxTableSize
  791.    /lzw_recycles := 0
  792.    if maxTableSize < 0 then maxTableSize := -maxTableSize
  793.    maxTableSize -:= 1
  794.    lzw_stringTable := list(*&cset)
  795.    every i := 1 to *lzw_stringTable do lzw_stringTable[i] := char(i - 1)
  796.    put(lzw_stringTable,EOF := *lzw_stringTable)  # reserve code=256 for EOF
  797.    charSize := *lzw_stringTable
  798.    if \lzw_trace then
  799.          write(&errout,"\nInput code\tOutput string\tNew table entry")
  800.    #
  801.    #  Decompress the input stream.
  802.    #
  803.    while old_strg :=
  804.          lzw_stringTable[Decompress_read_code(inproc,
  805.          *lzw_stringTable,EOF) + 1] do {
  806.       if \lzw_trace then
  807.             write(&errout,image(old_strg),"(",*lzw_stringTable,")",
  808.                   "\t",image(old_strg))
  809.       outproc(old_strg)
  810.       c := old_strg[1]
  811.       (while new_code := Decompress_read_code(inproc,
  812.             *lzw_stringTable + 1,EOF) do {
  813.          strg := lzw_stringTable[new_code + 1] | old_strg || c
  814.          outproc(strg)
  815.          c := strg[1]
  816.          if \lzw_trace then
  817.                write(&errout,image(char(*&cset > new_code) \ 1 | new_code),
  818.                      "(",*lzw_stringTable + 1,")","\t",
  819.                      image(strg),"\t\t",
  820.                      *lzw_stringTable," = ",image(old_strg || c))
  821.          if *lzw_stringTable < maxTableSize then
  822.                put(lzw_stringTable,old_strg || c)
  823.          else if tossTable >= 0 then {
  824.             lzw_stringTable := lzw_stringTable[1:charSize + 1]
  825.             lzw_recycles +:= 1
  826.             break
  827.             }
  828.          old_strg := strg
  829.          }) | break  # exit outer loop if this loop completed
  830.       }
  831.    Decompress_read_code()
  832.    return maxTableSize
  833. end
  834.  
  835.  
  836. procedure Decompress_read_code(inproc,stringTableSize,EOF)
  837.    local code
  838.    static max,bits,buffer,bufferbits,lastSize
  839.  
  840.    #
  841.    #  Initialize.
  842.    #
  843.    initial {
  844.       lastSize := 1000000
  845.       buffer := bufferbits := 0
  846.       }
  847.    #
  848.    #  Reinitialize if called with no arguments.
  849.    #
  850.    if /inproc then {
  851.       lastSize := 1000000
  852.       buffer := bufferbits := 0
  853.       return
  854.       }
  855.    #
  856.    #  Expand code size if necessary.
  857.    #
  858.    if stringTableSize < lastSize then {
  859.       max := 1
  860.       bits := 0
  861.       }
  862.    while stringTableSize > max do {
  863.       max *:= 2
  864.       bits +:= 1
  865.       }
  866.    #
  867.    #  Read in more data if necessary.
  868.    #
  869.    while bufferbits < bits do {
  870.       buffer := ior(ishift(buffer,8),ord(inproc())) |
  871.             stop("Premature end of file")
  872.       bufferbits +:= 8
  873.       }
  874.    #
  875.    #  Extract code from buffer and return.
  876.    #
  877.    code := ishift(buffer,bits - bufferbits)
  878.    buffer := ixor(buffer,ishift(code,bufferbits - bits))
  879.    bufferbits -:= bits
  880.    return EOF ~= code
  881. end
  882.  
  883.  
  884. procedure whole_wild_match(p,s)
  885.    return wild_match(p,s) > *s
  886. end
  887.  
  888.  
  889. procedure not_wild_match(p,s)
  890.    return not (wild_match(p,s) > *s)
  891. end
  892.  
  893.